home *** CD-ROM | disk | FTP | other *** search
/ MacFormat 1994 November / macformat-018.iso / Utility Spectacular / Developer / macgambit-20-compiler-src-p2 / Runtime (.scm & .s) / _errors.scm next >
Encoding:
Text File  |  1994-07-26  |  14.0 KB  |  459 lines  |  [TEXT/gamI]
  1. (##include "header.scm")
  2.  
  3. ;------------------------------------------------------------------------------
  4.  
  5. ; Traps from the runtime system.
  6.  
  7. (define (##trap-list-lengths name . args)
  8.   (##runtime-error "Lists are not of equal length" name args))
  9.  
  10. (define (##trap-list-lengths* name . args)
  11.   (##runtime-error* "Lists are not of equal length" name args))
  12.  
  13. (define (##trap-open-file name . args)
  14.   (##runtime-error "Can't open file" name args))
  15.  
  16. (define (##trap-open-file* name . args)
  17.   (##runtime-error* "Can't open file" name args))
  18.  
  19. (define (##trap-load msg name . args)
  20.   (##runtime-error
  21.     (if msg (##string-append "Can't load file " msg) "Can't load file")
  22.     name args))
  23.  
  24. (define (##trap-load* msg name . args)
  25.   (##runtime-error*
  26.     (if msg (##string-append "Can't load file " msg) "Can't load file")
  27.     name args))
  28.  
  29. (define (##trap-no-transcript name . args)
  30.   (##runtime-error "No transcript underway" name args))
  31.  
  32. (define (##trap-no-transcript* name . args)
  33.   (##runtime-error* "No transcript underway" name args))
  34.  
  35. (define (##trap-check-pair name . args)
  36.   (##runtime-error "PAIR expected" name args))
  37.  
  38. (define (##trap-check-pair* name . args)
  39.   (##runtime-error* "PAIR expected" name args))
  40.  
  41. (define (##trap-check-weak-pair name . args)
  42.   (##runtime-error "WEAK-PAIR expected" name args))
  43.  
  44. (define (##trap-check-weak-pair* name . args)
  45.   (##runtime-error* "WEAK-PAIR expected" name args))
  46.  
  47. (define (##trap-check-queue name . args)
  48.   (##runtime-error "QUEUE expected" name args))
  49.  
  50. (define (##trap-check-queue* name . args)
  51.   (##runtime-error* "QUEUE expected" name args))
  52.  
  53. (define (##trap-check-semaphore name . args)
  54.   (##runtime-error "SEMAPHORE expected" name args))
  55.  
  56. (define (##trap-check-semaphore* name . args)
  57.   (##runtime-error* "SEMAPHORE expected" name args))
  58.  
  59. (define (##trap-check-char name . args)
  60.   (##runtime-error "CHARACTER expected" name args))
  61.  
  62. (define (##trap-check-char* name . args)
  63.   (##runtime-error* "CHARACTER expected" name args))
  64.  
  65. (define (##trap-check-symbol name . args)
  66.   (##runtime-error "SYMBOL expected" name args))
  67.  
  68. (define (##trap-check-symbol* name . args)
  69.   (##runtime-error* "SYMBOL expected" name args))
  70.  
  71. (define (##trap-check-string name . args)
  72.   (##runtime-error "STRING expected" name args))
  73.  
  74. (define (##trap-check-string* name . args)
  75.   (##runtime-error* "STRING expected" name args))
  76.  
  77. (define (##trap-check-vector name . args)
  78.   (##runtime-error "VECTOR expected" name args))
  79.  
  80. (define (##trap-check-vector* name . args)
  81.   (##runtime-error* "VECTOR expected" name args))
  82.  
  83. (define (##trap-check-procedure name . args)
  84.   (##runtime-error "PROCEDURE expected" name args))
  85.  
  86. (define (##trap-check-procedure* name . args)
  87.   (##runtime-error* "PROCEDURE expected" name args))
  88.  
  89. (define (##trap-check-input-port name . args)
  90.   (##runtime-error "INPUT PORT expected" name args))
  91.  
  92. (define (##trap-check-input-port* name . args)
  93.   (##runtime-error* "INPUT PORT expected" name args))
  94.  
  95. (define (##trap-check-output-port name . args)
  96.   (##runtime-error "OUTPUT PORT expected" name args))
  97.  
  98. (define (##trap-check-output-port* name . args)
  99.   (##runtime-error* "OUTPUT PORT expected" name args))
  100.  
  101. (define (##trap-check-open-port name . args)
  102.   (##runtime-error "Open PORT expected" name args))
  103.  
  104. (define (##trap-check-open-port* name . args)
  105.   (##runtime-error* "Open PORT expected" name args))
  106.  
  107. (define (##trap-check-number name . args)
  108.   (##runtime-error "NUMBER expected" name args))
  109.  
  110. (define (##trap-check-real name . args)
  111.   (##runtime-error "REAL expected" name args))
  112.  
  113. (define (##trap-check-rational name . args)
  114.   (##runtime-error "RATIONAL expected" name args))
  115.  
  116. (define (##trap-check-integer name . args)
  117.   (##runtime-error "INTEGER expected" name args))
  118.  
  119. (define (##trap-check-exact-int name . args)
  120.   (##runtime-error "Exact INTEGER expected" name args))
  121.  
  122. (define (##trap-check-exact-int* name . args)
  123.   (##runtime-error* "Exact INTEGER expected" name args))
  124.  
  125. (define (##trap-check-range name . args)
  126.   (##runtime-error "Out of range" name args))
  127.  
  128. (define (##trap-check-range* name . args)
  129.   (##runtime-error* "Out of range" name args))
  130.  
  131. (define (##trap-divide-by-zero name . args)
  132.   (##runtime-error "Division by zero" name args))
  133.  
  134. (define (##trap-unimplemented name . args)
  135.   (##runtime-error "Unimplemented procedure" name args))
  136.  
  137. (define (##runtime-error msg name args)
  138.   (##signal '##SIGNAL.RUNTIME-ERROR msg name args))
  139.  
  140. (define (##runtime-error* msg name args)
  141.  
  142.   (define (fix l)
  143.     (if (##pair? (##cdr l)) (##cons (##car l) (fix (##cdr l))) (##car l)))
  144.  
  145.   (##signal '##SIGNAL.RUNTIME-ERROR msg name (fix args)))
  146.  
  147. ; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  148.  
  149. (define (##default-signal-catcher s args)
  150.   (if (##unbound? ##stderr)
  151.  
  152.     (##quit)
  153.  
  154.     (cond ((##eq? s '##SIGNAL.IO-ERROR)
  155.            (##handle-simple-error
  156.              #f
  157.              (##car args)
  158.              (##cdr args)
  159.              '()))
  160.  
  161.           ((##eq? s '##SIGNAL.READ-ERROR)
  162.            (##handle-simple-error
  163.              'read
  164.              (##car args)
  165.              (##cdr args)
  166.              '()))
  167.  
  168.           ((##eq? s '##SIGNAL.UNBOUND-DYNAMIC-VAR)
  169.            (##handle-simple-error
  170.              #f
  171.              "Unbound dynamic variable:"
  172.              (##list (##car args))
  173.             '()))
  174.  
  175.           ((##eq? s '##SIGNAL.GLOBAL-UNBOUND)
  176.            (##handle-interpreter-error
  177.              (##car args)
  178.              (##cadr args)
  179.              "Unbound variable:"
  180.              (##list (##decomp (##car args)))
  181.              '()))
  182.  
  183.           ((##eq? s '##SIGNAL.GLOBAL-UNBOUND-OPERATOR)
  184.            (##handle-call-error
  185.              (##car args)
  186.              (##cadr args)
  187.              "Unbound global variable in operator position"))
  188.  
  189.           ((##eq? s '##SIGNAL.GLOBAL-NON-PROCEDURE-OPERATOR)
  190.            (##handle-call-error
  191.              (##car args)
  192.              (##cadr args)
  193.              "Global variable in operator position is not a PROCEDURE"))
  194.  
  195.           ((##eq? s '##SIGNAL.NON-PROCEDURE-JUMP)
  196.            (##handle-call-error
  197.              (let ((x (##car args)))
  198.                (if (##self-eval? x) x (##list 'QUOTE x)))
  199.              (##cadr args)
  200.              "Operator is not a PROCEDURE"))
  201.  
  202.           ((##eq? s '##SIGNAL.NON-PROCEDURE-OPERATOR)
  203.            (##handle-interpreter-error
  204.              (##car args)
  205.              (##cadr args)
  206.              "Operator is not a PROCEDURE"
  207.              '()
  208.              (##list (##decomp (##car args)))))
  209.  
  210.           ((##eq? s '##SIGNAL.NON-PROCEDURE-SEND)
  211.            (##handle-interpreter-error
  212.              (##car args)
  213.              (##cadr args)
  214.              "PROCEDURE expected after '=>':"
  215.              '()
  216.              (##list (##decomp (##car args)))))
  217.  
  218.           ((##eq? s '##SIGNAL.WRONG-NB-ARG)
  219.            (##handle-call-error
  220.              (##car args)
  221.              (##cadr args)
  222.              "Wrong number of arguments passed to procedure"))
  223.  
  224.           ((##eq? s '##SIGNAL.APPLY-ARG-LIMIT)
  225.            (##handle-call-error
  226.              (##car args)
  227.              (##cadr args)
  228.              "Argument count to APPLY exceeds implementation limit"))
  229.  
  230.           ((##eq? s '##SIGNAL.HEAP-OVERFLOW)
  231.            (##handle-simple-error
  232.              #f
  233.              "Heap overflow"
  234.              '()
  235.              '()))
  236.  
  237.           ((##eq? s '##SIGNAL.STACK-OVERFLOW)
  238.            (##handle-simple-error
  239.              #f
  240.              "Stack overflow"
  241.              '()
  242.              '()))
  243.  
  244.           ((##eq? s '##SIGNAL.PLACEHOLDER-ALREADY-DETERMINED)
  245.            (##handle-simple-error
  246.              #f
  247.              "Placeholder already determined"
  248.              '()
  249.              '()))
  250.  
  251.           ((##eq? s '##SIGNAL.DEADLOCK)
  252.            (##handle-simple-error
  253.              #f
  254.              "Deadlock detected"
  255.              '()
  256.              '()))
  257.  
  258.           ((##eq? s '##SIGNAL.RUNTIME-ERROR)
  259.            (##handle-call-error
  260.              (##cadr args)
  261.              (##caddr args)
  262.              (##car args)))
  263.  
  264.           ((##eq? s '##SIGNAL.GLOBAL-ENV-OVERFLOW)
  265.            (##handle-simple-error
  266.              '[COMPILATION]
  267.              "Global variable table overflow"
  268.              '()
  269.              '()))
  270.  
  271.           ((##eq? s '##SIGNAL.SYNTAX-ERROR)
  272.            (##handle-simple-error
  273.              '[COMPILATION]
  274.              (##cadr args)
  275.              (##cddr args)
  276.              (##list (##car args))))
  277.  
  278.           (else
  279.            (##write-string "*** ERROR -- Signal not caught, " ##stderr)
  280.            (##write s ##stderr #f)
  281.            (##write-string " " ##stderr)
  282.            (##write args ##stderr #f)
  283.            (##newline ##stderr)
  284.            (##quit)))))
  285.  
  286. (define (##handle-simple-error proc msg args pps)
  287.   (##sequentially (lambda ()
  288.     (##identify-error proc msg args pps)
  289.     (##pop-repl))))
  290.  
  291. (define (##handle-interpreter-error code rte msg args pps)
  292.   (##subproblem-apply0 code rte
  293.     (lambda ()
  294.       (##call-with-current-continuation (lambda (cont) (##sequentially (lambda ()
  295.         (##identify-error (##extract-proc code rte) msg args pps)
  296.         (##debug-repl cont))))))))
  297.  
  298. (define (##handle-call-error proc args msg)
  299.   (##call-with-current-continuation (lambda (cont) (##sequentially (lambda ()
  300.  
  301.     (define (add-quotes l)
  302.       (if (##pair? l)
  303.         (let ((x (##car l)))
  304.           (##cons (if (##self-eval? x) x (##list 'QUOTE x))
  305.                   (add-quotes (##cdr l))))
  306.         '()))
  307.  
  308.     (##identify-error #f msg '() '())
  309.  
  310.     (let ((out (##repl-out)))
  311.       (let ((call (##cons (if (##procedure? proc)
  312.                             (##procedure-name proc)
  313.                             proc)
  314.                           (add-quotes args)))
  315.             (width (##port-width out)))
  316.         (let ((str (##object->string call width (if-touches #t #f))))
  317.           (if (##fixnum.< (##string-length str) width)
  318.             (##write-string str out)
  319.             (begin
  320.               (##write-string "(" out)
  321.               (##write-string (##object->string
  322.                                 (##car call)
  323.                                 (##fixnum.- width 1)
  324.                                 (if-touches #t #f))
  325.                               out)
  326.               (##newline out)
  327.  
  328.               (let loop ((l (##cdr call)))
  329.                 (if (##pair? l)
  330.                   (begin
  331.                     (##write-string "  " out)
  332.                     (##write-string (##object->string
  333.                                       (##car l)
  334.                                       (##fixnum.- width 2)
  335.                                       (if-touches #t #f))
  336.                                     out)
  337.                     (##newline out)
  338.                     (loop (##cdr l)))))
  339.  
  340.               (##write-string ")" out)))
  341.  
  342.           (##newline out)
  343.           (##debug-repl cont)))))))))
  344.  
  345. (define (##identify-error proc msg args pps)
  346.   (let ((out (##repl-out)))
  347.     (##write-string "*** ERROR" out)
  348.     (if proc
  349.       (begin
  350.         (##write-string " IN " out)
  351.         (##write (if (##procedure? proc)
  352.                    (##procedure-name proc)
  353.                    proc)
  354.                  out
  355.                  #f)))
  356.     (##write-string " -- " out)
  357.     (##display msg out #f)
  358.     (let loop1 ((l args))
  359.       (if (##pair? l)
  360.         (begin
  361.           (##write-string " " out)
  362.           (##write (##car l) out #f)
  363.           (loop1 (##cdr l)))
  364.         (begin
  365.           (##newline out)
  366.           (let loop2 ((l pps))
  367.             (if (##pair? l)
  368.               (begin
  369.                 (##pretty-print (##car l) out (##port-width out))
  370.                 (loop2 (##cdr l))))))))))
  371.  
  372. (define ##user-interrupt #f)
  373.  
  374. (set! ##user-interrupt
  375.   (lambda ()
  376.     (##call-with-current-continuation (lambda (cont) (##sequentially (lambda ()
  377.       (let ((out (##repl-out)))
  378.         (##newline out)
  379.         (##write-string "*** INTERRUPT" out)
  380.         (##newline out)
  381.         (##debug-repl cont))))))))
  382.  
  383. ; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  384.  
  385. (define (##signal sig . args)
  386.   (let ((signal-catcher
  387.           (##dynamic-ref '##SIGNAL-CATCHER ##default-signal-catcher)))
  388.     (signal-catcher sig args)))
  389.  
  390. (define (##catch-all signal-catcher thunk)
  391.   (##dynamic-bind (##list (##cons '##SIGNAL-CATCHER signal-catcher)) thunk))
  392.  
  393. (define (##catch-signal sig signal-catcher thunk)
  394.   (let ((parent-signal-catcher
  395.           (##dynamic-ref '##SIGNAL-CATCHER ##default-signal-catcher)))
  396.     (##catch-all (lambda (s args)
  397.                    (if (##eq? s sig)
  398.                      (signal-catcher s args)
  399.                      (parent-signal-catcher s args)))
  400.                  thunk)))
  401.  
  402. ;------------------------------------------------------------------------------
  403.  
  404. ; Exceptions raised by low level runtime system
  405.  
  406. (##declare (not intr-checks))
  407.  
  408. (define (##exception.global-jump ind . args)
  409.   (let ((val (##global-var-ref ind)))
  410.     (touch-vars (val)
  411.       (if (##procedure? val)
  412.         (##apply val args)
  413.         (let ((name (##index->global-var-name ind)))
  414.           (if (##unbound? val)
  415.             (##signal '##SIGNAL.GLOBAL-UNBOUND-OPERATOR name args)
  416.             (##signal '##SIGNAL.GLOBAL-NON-PROCEDURE-OPERATOR name args)))))))
  417.  
  418. (define (##exception.non-proc-jump proc . args)
  419.   (touch-vars (proc)
  420.     (if (##procedure? proc)
  421.       (##apply proc args)
  422.       (##signal '##SIGNAL.NON-PROCEDURE-JUMP proc args))))
  423.  
  424. (define (##exception.wrong-nb-arg proc . args)
  425.   (##signal '##SIGNAL.WRONG-NB-ARG proc args))
  426.  
  427. (define (##exception.apply-arg-limit proc args)
  428.   (##signal '##SIGNAL.APPLY-ARG-LIMIT proc args))
  429.  
  430. (define (##exception.heap-overflow)
  431.   (##signal '##SIGNAL.HEAP-OVERFLOW))
  432.  
  433. (define (##exception.stack-overflow)
  434.   (##signal '##SIGNAL.STACK-OVERFLOW))
  435.  
  436. (define (##exception.placeholder-already-determined)
  437.   (##signal '##SIGNAL.PLACEHOLDER-ALREADY-DETERMINED))
  438.  
  439. (define (##exception.deadlock)
  440.   (##signal '##SIGNAL.DEADLOCK))
  441.  
  442. (define (##exception.read-not-ready val)
  443.   (let ((proc ##read-not-ready)) (if (##procedure? proc) (proc val) -1)))
  444.  
  445. (define (##exception.write-not-ready val)
  446.   (let ((proc ##write-not-ready)) (if (##procedure? proc) (proc val) -1)))
  447.  
  448. (define (##exception.timer-interrupt)
  449.   (let ((proc ##timer-interrupt)) (if (##procedure? proc) (proc))))
  450.  
  451. (define (##exception.user-interrupt)
  452.   (let ((proc ##user-interrupt)) (if (##procedure? proc) (proc))))
  453.  
  454. (define (##exception.gc-finalize arg)
  455.   (let ((proc ##gc-finalize)) (if (##procedure? proc) (proc)))
  456.   arg)
  457.  
  458. ;------------------------------------------------------------------------------
  459.